Chat Server
concurrencyicon.icon
Simple chatting server which is an example of concurrency program in Haksell.
code:chat.hs
{-# LANGUAGE RecordWildCards #-} module Chat where
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import Data.Char
import qualified Data.Map as M
import Network
import System.IO
type ClientName = String
-- Act as message channel
data Client = Client
{ clientName :: ClientName
, clientHandle :: Handle
, clientKicked :: TVar (Maybe String)
, clientSendChan :: TChan Message
}
data Message =
Notice String
| Tell ClientName String
| Broadcast ClientName String
| Command String
deriving (Show)
newClient :: ClientName -> Handle -> STM Client
newClient name h = do
kicked <- newTVar Nothing
chan <- newTChan
return $ Client name h kicked chan
-- wrtite to Tchan
sendMessage :: Client -> Message -> STM ()
sendMessage Client{..} = writeTChan clientSendChan
data Server = Server
{ serverClients :: TVar (M.Map ClientName Client)
}
newServer :: IO Server
newServer = do
c <- newTVarIO M.empty
return $ Server c
-- broadcast message to everyone registered on serverClients
broadcast :: Server -> Message -> STM ()
broadcast Server{..} msg = do
clients <- readTVar serverClients
mapM_ (\client -> sendMessage client msg) (M.elems clients)
sendToName :: Server -> ClientName -> Message -> STM Bool
sendToName Server{..} name msg = do
clients <- readTVar serverClients
case M.lookup name clients of
Nothing -> return False
Just client -> sendMessage client msg >> return True
run :: IO ()
run = do
server <- newServer
let port = 44444
s <- listenOn (PortNumber port)
putStrLn $ "Listening on port " ++ show port
forever $ do
(h, chost, cport) <- accept s
putStrLn $ "Accepted connection from " ++ show chost ++ ":" ++ show cport
forkFinally (talk h server) (const $ hClose h)
checkAddClient :: Server -> ClientName -> Handle -> IO (Maybe Client)
checkAddClient server@Server{..} name handle = atomically $ do
clients <- readTVar serverClients -- read Map
if M.member name clients -- if name exists in map
then return Nothing
else do
client <- newClient name handle -- register new client
writeTVar serverClients $ M.insert name client clients -- write it
broadcast server $ Notice (name ++ " has connected") -- Broadcast
return (Just client)
removeClient :: Server -> ClientName -> IO ()
removeClient server@Server{..} name = atomically $ do
modifyTVar' serverClients $ M.delete name
broadcast server $ Notice (name ++ " has disconnected")
talk :: Handle -> Server -> IO ()
talk h server@Server{..} = do
hSetNewlineMode h universalNewlineMode -- Set NewlineMode
hSetBuffering h LineBuffering -- Set setBuffering
negotiateName -- Negotiate name
where
negotiateName = do
hPutStrLn h "What is your name?"
name <- hGetLine h
unless (validName name) negotiateName
ok <- checkAddClient server name h -- Write or check the serverClient
case ok of
Nothing -> do
hPutStrLn h $ "Name is in use, please choose another ..."
negotiateName
Just client -> do
runClient server client finally removeClient server name -- run client process
-- We will talk about asynchronous exceptions in more detail later.
validName :: String -> Bool
validName x = not (null x) && all isLetter x
runClient :: Server -> Client -> IO ()
runClient server@Server{..} client@Client{..} =
void $ race receive serve --takes either receive or serve
where
-- send message
receive :: IO ()
receive = forever $ do
msg <- hGetLine clientHandle
atomically $ sendMessage client (Command msg)
serve :: IO ()
serve = join $ atomically $ do
kicked <- readTVar clientKicked
case kicked of
Just reason ->
return $ hPutStrLn clientHandle $ "You have been kicked: " ++ reason
Nothing -> do
msg <- readTChan clientSendChan --read messages from client
return $ handleMessage server client msg serve -- handle message
handleMessage :: Server -> Client -> Message -> IO () -> IO ()
handleMessage server client@Client{..} msg cont = -- cont = serve :: IO ()
case msg of -- Describe how output message should be formatted
Notice msg -> output $ "*** " ++ msg
Tell name msg -> output $ "*" ++ name ++ "*: " ++ msg
Broadcast name msg -> output $ "<" ++ name ++ ">: " ++ msg
Command msg -> -- Describe how user's command should be handled
case words msg of
"/kick" : who : [] -> atomically (kick server client who) >> cont -- creates loop
"/tell" : who : what -> tell server client who (unwords what) >> cont
"/quit" : [] -> return ()
_ -> atomically (broadcast server (Broadcast clientName msg)) >> cont
where
output :: String -> IO ()
output txt =
hPutStrLn clientHandle txt >> cont -- Show message
kick :: Server -> Client -> ClientName -> STM ()
kick server@Server{..} client who = do
clients <- readTVar serverClients
case M.lookup who clients of --Lookup by name
Nothing -> sendMessage client (Notice $ who ++ " is not connected.")
Just victim -> do
writeTVar (clientKicked victim) $ Just $ "by " ++ clientName client
sendMessage client (Notice $ "you kicked " ++ who)
tell :: Server -> Client -> ClientName -> String -> IO ()
tell server@Server{..} client@Client{..} who msg = do
ok <- atomically $ sendToName server who (Tell clientName msg)
unless ok $ atomically $ sendMessage client (Notice $ who ++ " is not connected.")
RecordWildCards
code:recordWildCards.hs
aXb T { a = a, b = b } = a * b
{-# LANGUAGE RecordWildCards #-} aXb T {..} = a * b
hSetNewlineMode :: Handle -> NewlineMode -> IO ()
Set the NewlineMode on the specified Handle. All buffered data is flushed first.
data NewlineMode
Specifies the translation, if any, of newline characters between internal Strings and the external file or stream. Haskell Strings are assumed to represent newlines with the '\n' character; the newline mode specifies how to translate '\n' on output, and what to translate into '\n' on input.
void :: Functor f => f a -> f ()
Void value discards or ignores the result of evaluation, such as the return value of an IO action.